perm filename IMDRAW[1,LMM]1 blob
sn#021331 filedate 1973-01-23 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE "23-JAN-73 14:35:09")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE IMDRAWVARS)
T)
(RPAQQ IMDRAWVARS
((FNS XDRAW LABEL POSLABEL STARTDRAW STOPDRAW DELETEDRAW
INITDRAW LINE SETSCALE HOME XCENTER POS XPOSITION DLINA
DCHRA FLIPXY DGTCHR DINCS FNDCH OTCHRS SCALX SCALY SCALE
SETPOS POSCHRS POSCHR DPOS DXPOS CKPOS ERMES EXPTEXT
GRAPHTEXT MIN MAX RECIP SQUARE)
(VARS DCHRS)
(FNS LAYOUT ANALIN SORTLN STRLNA FINDNDS STKNDS SETND RTLIN
CONCT OUTNDS CKINT SLOPE SRTLNA)
(FNS DRAW DRAWS PRINRAD PRINENTRY PAUSE)
(FNS /ONCOC RESETCOC SFCOC SETCOC M RFCOC PRINBRIT CLEAR
ONCOC)
(PROP MACRO RESETCOC)))
(DEFINEQ
(XDRAW
[LAMBDA (X Y)
(OTCHRS (DLINA (SCALX X)
(SCALY Y])
(LABEL
[LAMBDA (MS)
(GRAPHTEXT (EXPTEXT MS])
(POSLABEL
[LAMBDA (X Y MS)
(PROG2 (POS X Y)
(LABEL MS])
(STARTDRAW
[LAMBDA NIL
(PRIN1 (CHARACTER 14])
(STOPDRAW
[LAMBDA NIL
(PRIN1 (CHARACTER 15])
(DELETEDRAW
[LAMBDA NIL
(PROG2 (PRIN1 (CHARACTER 26))
(CENTER])
(INITDRAW
[LAMBDA NIL
(PROG NIL
(ONCOC 14)
(ONCOC 15)
(ONCOC 26)
(SETSCALE 0 1024 0 1024)
(DELETEDRAW])
(LINE
[LAMBDA (X1 Y1 X2 Y2)
(PROG2 (POS X1 Y1)
(XDRAW X2 Y2])
(SETSCALE
[LAMBDA (XMN XMX YMN YMX)
(PROG NIL
(SETQ XBOT (MINUS XMN))
[SETQ XSCL (QUOTIENT 81.0 (PLUS 1 (DIFFERENCE XMX XMN]
(SETQ YBOT (MINUS YMN))
(SETQ YSCL (QUOTIENT 81.0 (PLUS 1 (DIFFERENCE YMX YMN])
(HOME
[LAMBDA NIL
(PROG2 (OTCHRS (LIST (CHARACTER 53)))
(SETPOS 0 80])
(XCENTER
[LAMBDA NIL
(PROG2 (OTCHRS (LIST (CHARACTER 45)))
(SETPOS 40 40])
(POS
[LAMBDA (X Y)
(OTCHRS (DPOS (SCALX X)
(SCALY Y])
(XPOSITION
[LAMBDA (X)
(OTCHRS (DXPOS (SCALX X])
(DLINA
[LAMBDA (X1 Y1)
(PROG (DX DY SL D L X Y SLA)
(SETQ DX (DIFFERENCE X1 XPOS))
(SETQ DY (DIFFERENCE Y1 YPOS))
(COND
((AND (ZEROP DX)
(ZEROP DY))
(RETURN NIL)))
[SETQ SL (COND
((ZEROP DX)
1024.0)
(T (ABS (QUOTIENT (FLOAT DY)
DX]
[SETQ SLA (COND
((ZEROP DY)
1024.0)
((ZEROP DX)
0.0)
(T (RECIP SL]
(SETQ INC 0.0)
(SETQ Y (GREATERP (ABS DX)
(ABS DY)))
A [SETQ D (COND
(Y (DCHRA DX DY SL))
(T (FLIPXY (DCHRA DY DX SLA]
(SETQ X (DINCS D))
(SETQ L (CONS (DGTCHR D)
L))
(SETQ DX (DIFFERENCE DX (CAR X)))
(SETQ DY (DIFFERENCE DY (CADR X)))
(SETPOS (PLUS XPOS (CAR X))
(PLUS YPOS (CADR X)))
[COND
[(CKPOS)
(RETURN (REVERSE (CDR L]
((AND (ZEROP DX)
(ZEROP DY))
(RETURN (REVERSE L]
(GO A])
(DCHRA
[LAMBDA (DX DY SL)
(PROG (X Y)
(SETQ X (FIX (PLUS INC SL SL .5)))
[COND
((ZEROP X)
NIL)
((GREATERP DY 0)
(SETQ X (DIFFERENCE 16 X]
[COND
((LESSP DX 0)
(SETQ X (DIFFERENCE 8 X]
[COND
((LESSP X 0)
(SETQ X (PLUS X 16]
(SETQ Y (COND
((AND (EQUAL SL 0)
(GREATERP (ABS DX)
7))
8)
((GREATERP (ABS DX)
1)
2)
(T 1)))
(SETQ INC (PLUS INC (TIMES Y SL)))
(SETQ DX (FIX (PLUS INC .5)))
(SETQ INC (DIFFERENCE INC DX))
(RETURN (LIST Y X])
(FLIPXY
[LAMBDA (X)
(PROG (Y)
(SETQ Y (DIFFERENCE 12 (CADR X)))
[COND
((MINUSP Y)
(SETQ Y (PLUS 16 Y]
(RETURN (LIST (CAR X)
Y])
(DGTCHR
[LAMBDA (DD)
(CAR (FNDCH D])
(DINCS
[LAMBDA (D)
(CADDR (FNDCH D])
(FNDCH
[LAMBDA (D)
(PROG (X)
(SETQ X DCHRS)
A [COND
((NULL X)
(RETURN NIL))
((EQUAL D (CADAR X))
(RETURN (CAR X]
(SETQ X (CDR X))
(GO A])
(OTCHRS
[LAMBDA (L)
(PROG (X)
(STARTDRAW)
(FOR X IN L DO (PRIN1 X))
(STOPDRAW])
(SCALX
[LAMBDA (X)
(SCALE X XBOT XSCL])
(SCALY
[LAMBDA (Y)
(SCALE Y YBOT YSCL])
(SCALE
[LAMBDA (X XMN XMP)
(PROG NIL
(SETQ X (FIX (PLUS (TIMES XMP (PLUS X XMN))
.5)))
(RETURN (COND
((LESSP X 0)
0)
((GREATERP X 80)
80)
(T X])
(SETPOS
[LAMBDA (X Y)
(PROG NIL
(SETQ XPOS X)
(SETQ YPOS Y])
(POSCHRS
[LAMBDA (X)
(PROG (X1)
(SETQ X (PLUS (TIMES X 2)
48))
(SETQ X1 (FIX (QUOTIENT X 16)))
(SETQ X (DIFFERENCE X (TIMES X1 16)))
(RETURN (LIST (POSCHR X1)
(POSCHR X])
(POSCHR
[LAMBDA (X)
(PROG (Y)
[SETQ Y
(CONS (CHARACTER 64)
(QUOTE (A B C D E F G H I J K L M N O]
A [COND
((ZEROP X)
(RETURN (CAR Y]
(SETQ X (SUB1 X))
(SETQ Y (CDR Y))
(GO A])
(DPOS
[LAMBDA (X Y)
(PROG NIL
(SETPOS X Y)
(CKPOS)
(RETURN (CONS (CHARACTER 46)
(APPEND (POSCHRS X)
(POSCHRS Y])
(DXPOS
[LAMBDA (X)
(PROG NIL
(SETQ XPOS X)
(CKPOS)
(RETURN (CONS (CHARACTER 42)
(POSCHRS (SCALX X])
(CKPOS
[LAMBDA NIL
(PROG NIL
(COND
((OR (GREATERP XPOS 80)
(MINUSP XPOS))
(GO A))
((OR (GREATERP YPOS 80)
(MINUSP YPOS))
(GO B))
(T (RETURN NIL)))
A (ERMES (QUOTE (X POS OFF SCREEN)))
(SETQ XPOS (MIN 80 (MAX 0 XPOS)))
C (DPOS XPOS YPOS)
(RETURN T)
B (ERMES (QUOTE (Y POS OFF SCREEN)))
(SETQ YPOS (MIN 80 (MAX 0 YPOS)))
(GO C])
(ERMES
[LAMBDA (MS)
(PROG NIL
(STOPDRAW)
(PRINT MS)
(STARTDRAW)
(RETURN NIL])
(EXPTEXT
[LAMBDA (X)
(PROG (L Y Z)
[COND
((ATOM X)
(SETQ X (LIST X]
[FOR Y IN X DO (SETQ L (APPEND L (CONS (CHARACTER 32)
(UNPACK Y]
(RETURN L])
(GRAPHTEXT
[LAMBDA (X)
(PROG (Y)
(STARTDRAW)
(FOR Y IN X DO (SETQ XPOS (ADD1 XPOS))
(COND
((CKPOS)
(RETURN NIL)))
(PRIN1 (CHARACTER 44))
(PRIN1 Y))
A (STOPDRAW)
(RETURN NIL])
(MIN
[LAMBDA (X Y)
(COND
((LESSP X Y)
X)
(T Y])
(MAX
[LAMBDA (X Y)
(COND
((LESSP X Y)
Y)
(T X])
(RECIP
[LAMBDA (X)
(COND
((ZEROP X)
1024)
(T (QUOTIENT 1.0 X])
(SQUARE
[LAMBDA (X)
(PRINBRIT "-90YZ"])
)
[RPAQQ DCHRS ((0 (8 4)
(0 -8))
(1 (1 0)
(1 0))
(2 (1 2)
(1 -1))
(3 (1 4)
(0 -1))
(4 (1 6)
(-1 -1))
(5 (1 8)
(-1 0))
(6 (1 10)
(-1 1))
(7 (1 12)
(0 1))
(8 (1 14)
(1 1))
(9 (8 0)
(8 0))
(A (2 0)
(2 0))
(B (2 1)
(2 -1))
(C (2 2)
(2 -2))
(D (2 3)
(1 -2))
(E (2 4)
(0 -2))
(F (2 5)
(-1 -2))
(G (2 6)
(-2 -2))
(H (2 7)
(-2 -1))
(I (2 8)
(-2 0))
(J (2 9)
(-2 1))
(K (2 10)
(-2 2))
(L (2 11)
(-1 2))
(M (2 12)
(0 2))
(N (2 13)
(1 2))
(O (2 14)
(2 2))
(P (2 15)
(2 1))
(Q (-1 0)
(1 0))
(R (-1 2)
(1 -1))
(S (-1 4)
(0 -1))
(T (-1 6)
(-1 -1))
(U (-1 8)
(-1 0))
(V (-1 10)
(-1 1))
(W (-1 12)
(0 1))
(X (-1 14)
(1 1))
(Y (8 8)
(-8 0))
(Z (8 12)
(0 8]
(DEFINEQ
(LAYOUT
[LAMBDA (X)
(PROG (X1)
(OR (ARRAYP (CAR (QUOTE NODE)))
(SETQ NODE (ARRAY 40 0 0)))
(OR (ARRAYP (CAR (QUOTE CONN)))
(SETQ CONN (ARRAY 20 0 NIL)))
(OR (ARRAYP (CAR (QUOTE TMP)))
(SETQ TMP (ARRAY 20 0 0)))
(ANALIN X)
(SORTLN)
(FINDNDS 1 NIL)
(SETQ X1 (OUTNDS))
(RETURN X1])
(ANALIN
[LAMBDA (X)
(PROG (X1 X2 X3 X4)
(SETQ TITLE (CAR X))
(SETQ LINE NIL)
(SETQ LABEL NIL)
(SETQ NLN (LENGTH (CDR X)))
(SETQ NMX 0)
[FOR X1 IN (CDR X)
AS NMX IS (MAX (CAR X1)
NMX)
AS X2 IS (CAR X1)
AS LABEL IS (CONS (CONS X2 (CADR X1))
LABEL) FOR X3
IN (CDDR X1)
DO (SETQ X4 (SASSOC (CONS X2 X3)
LINE))
[COND
[(NULL X4)
(COND
((SASSOC (CONS X3 X2)
LINE)
NIL)
(T (SETQ LINE (CONS (LIST (CONS X2 X3)
1)
LINE]
(T (RPLACA (CDR X4)
(ADD1 (CADR X4]
(COND
((MEMBER X3 (ELT CONN X2))
NIL)
(T (SETA CONN X2 (CONS X3 (ELT CONN X2]
(SETQ LLN (LENGTH LINE))
(RETURN LINE])
(SORTLN
[LAMBDA NIL
(PROG (L X X1 X2 X3 Y Y1)
[FOR I :=(1 NMX) DO (SETA TMP I (LENGTH (ELT CONN I]
(SETQ L NIL)
(SETQ Y1 (TIMES NMX 10))
(SETQ Y NIL)
A (SETQ X1 0)
(SETQ X2 NIL)
[FOR X IN LINE IF (NOT (MEMBER X L))
DO [SETQ X3 (PLUS (ELT TMP (CAAR X))
(ELT TMP (CDAR X]
(COND
((LESSP X1 X3)
(PROG2 (SETQ X1 X3)
(SETQ X2 X]
[COND
((AND Y (NOT (MEMBER (CAAR X2)
Y)))
(RPLACA X2 (CONS (CDAR X2)
(CAAR X2]
(SETQ Y (SRTLNA (CAAR X2)
Y Y1))
(SETQ Y (SRTLNA (CDAR X2)
Y Y1))
(SETQ Y1 (PLUS Y1 -10))
(SETQ L (CONS X2 L))
(COND
((LESSP (LENGTH L)
LLN)
(GO A)))
(SETQ LINE (REVERSE L))
(RETURN LINE])
(STRLNA
[LAMBDA (X Y Y1)
(PROG NIL
(COND
((MEMBER X Y)
(RETURN Y)))
(SETA TMP X (PLUS (ELTA TMP X)
Y1))
(RETURN (CONS X Y])
(FINDNDS
[LAMBDA (RA RI)
(PROG (X1 X2 X3 L1)
F (FOR I :=(1 NMX) DO (SETA NODE I 0)
(SETA NODE (IPLUS 20 I)
0))
(SETND (CAAAR LINE)
(QUOTE (50 . 50)))
(SETQ STACK (LIST 0 LINE))
(SETQ L1 NIL)
(SETQ X3 T)
C (SETQ X1 (CAR LINE))
(SETQ X2 (CDAR X1))
(COND
((ZEROP (ELT NODE X2))
NIL)
((RTLIN RI X1 L1)
(GO B))
(T (GO A)))
(COND
(X3 (STKNDS X2 L1)))
A (SETQ X3 (CAR STACK))
(SETQ STACK (CDR STACK))
(COND
((ATOM X3)
(GO D)))
(SETND (CADR X3)
(CAR X3))
(COND
((RTLIN RI X1 L1)
(GO NXT)))
(SETND (CADR X3)
(QUOTE (0 . 0)))
(GO A)
NXT (SETQ L1 (CONS X1 L1))
(SETQ LINE (CDR LINE))
(SETQ X3 T)
(COND
(LINE (GO C))
(T (RETURN NIL)))
B [SETQ STACK (CONS NIL (CONS (CONS (CAR L1)
LINE)
(CONS (CDR L1)
STACK]
(GO NXT)
D (SETQ LINE (CAR STACK))
(SETQ L1 (CADR STACK))
(SETQ STACK (CDDR STACK))
(SETQ X1 (CAR LINE))
(COND
((NULL STACK)
(GO E)))
[COND
(X3 (SETND X3 (QUOTE (0 . 0]
(COND
((ATOM (CAR STACK))
(GO A)))
(SETA NODE (CADAR STACK)
0)
(SETQ X3 NIL)
(GO C)
E (SETQ RA (ADD1 RA))
(COND
((GREATERP RA 3)
(SETQ RI T)))
(GO F])
(STKNDS
[LAMBDA (X L1)
(PROG (Y X1 XNM XMX YMN YMX N1 N2)
[SETQ STACK (CONS X (CONS (CONS (CAR L1)
LINE)
(CONS (CDR L1)
STACK]
(SETQ XMN 0)
(SETQ XMX 100)
(SETQ YMN 0)
(SETQ YMX 100)
[COND
((LESSP (LENGTH STACK)
6)
(PROG2 (SETQ XMN 51)
(SETQ YMN 50]
[FOR X1 IN (ELT CONN X)
AS N1 IS (ELT NODE X1)
IF (NOT (ZEROP N1))
AS N2 IS (ELT NODE (IPLUS X1 20))
DO (SETQ XMN (MAX XMN (DIFFERENCE N1 RA)))
(SETQ XMX (MIN XMX (PLUS N1 RA)))
(SETQ YMN (MAX YMN (DIFFERENCE N2 RA)))
(SETQ YMX (MIN YMX (PLUS N2 RA]
(COND
((OR (GREATERP XMN XMX)
(GREATERP YMN YMX))
(RETURN NIL)))
[SETQ Y (FOR I :=(1 NMX)
LIST
(CONS (ELT NODE I)
(ELT NODE (IPLUS I 20]
(SETQ X1 NIL)
(FOR N1 :=(XMN XMX) FOR N2 :=(YMN YMX)
IF (NOT (MEMBER (CONS N1 N2)
Y))
DO (SETQ X1 T)
(SETQ STACK (CONS (LIST (CONS N1 N2)
X)
STACK)))
(COND
((NULL X1)
(RETURN NIL)))
(RETURN T])
(SETND
[LAMBDA (X Y)
(PROG NIL
(SETA NODE X (CAR Y))
(SETA NODE (IPLUS X 20)
(CDR Y))
(RETURN Y])
(RTLIN
[LAMBDA (RI X L1)
(PROG (X1 X2 Y1 Y2 N1 N2 Y Z)
(COND
((NULL L1)
(RETURN T)))
(SETQ N1 (CAAR X))
(SETQ N2 (CDAR X))
(SETQ X1 (ELT NODE N1))
(SETQ X2 (ELT NODE N2))
(SETQ Y1 (ELT NODE (IPLUS N1 20)))
(SETQ Y2 (ELT NODE (IPLUS N2 20)))
[SETQ Z (FOR Y
IN L1 AS Z IS (CONCT X Y)
AS N1 IS (CAAR Y)
AS N2 IS (CDAR Y)
AND (CKINT Z RI X1 X2 Y1 Y2
(SLOPE X1 X2 Y1 Y2)
(ELT NODE N1)
(ELT NODE N2)
(ELT NODE (IPLUS N1 20))
(ELT NODE (IPLUS N2 20]
(RETURN Z])
(CONCT
[LAMBDA (X Y)
(OR (EQUAL (CAAR Y)
(CAAR X))
(EQUAL (CAAR Y)
(CDAR X))
(EQUAL (CDAR Y)
(CAAR X))
(EQUAL (CDAR Y)
(CDAR X])
(OUTNDS
[LAMBDA NIL
(PROG (X I X1)
(INITDRAW)
(SETSCALE 45 55 45 55)
(POSLABEL 48 48 TITLE)
(FOR I :=(1 NMX) WHEN (NOT (ZEROP (ELT NODE I)))
AS NEW LL IS (CDR (ASSOC I LABEL))
DO (POSLABEL (ELT NODE I)
(ELT NODE (IPLUS I 20))
(OR LL I)))
[FOR NEW LIN IN (CAR (LAST STACK))
DO (LINE (ELT NODE (CAAR LIN))
(ELT NODE (IPLUS (CAAR LIN)
20))
(ELT NODE (CDAR LIN))
(ELT NODE (IPLUS (CDAR LIN)
20]
(RETURN (REVERSE X])
(CKINT
[LAMBDA (Z RI X1 X2 Y1 Y2 S1 A1 A2 B1 B2)
(PROG (S2 X Y)
(SETQ S2 (SLOPE A1 A2 B1 B2))
(COND
((EQUAL S1 S2)
(GO D))
((EQUAL (CAR S1)
(CAR S2))
(RETURN T))
(Z (RETURN T))
(RI (RETURN T)))
(COND
((EQUAL X1 X2)
(GO A))
((EQUAL A1 A2)
(GO B)))
[SETQ X (QUOTIENT (DIFFERENCE (CDR S2)
(CDR S1))
(DIFFERENCE (CAR S1)
(CAR S2]
(SETQ Y (PLUS (TIMES (CAR S1)
X)
(CDR S1)))
C (COND
((OR (GREATERP X (MAX X1 X2))
(LESSP X (MIN X1 X2))
(GREATERP Y (MAX Y1 Y2))
(LESSP Y (MIN Y1 Y2))
(GREATERP X (MAX A1 A2))
(LESSP X (MIN A1 A2))
(GREATERP Y (MAX B1 B2))
(LESSP Y (MIN B1 B2)))
(RETURN T))
(T (RETURN NIL)))
D (COND
((OR (GREATERP (MIN X1 X2)
(MAX A1 A2))
(GREATERP (MIN A1 A2)
(MAX X1 X2)))
(RETURN T))
(T (RETURN NIL)))
A (SETQ Y (PLUS (TIMES (CAR S2)
(CDR S1))
(CDR S2)))
(SETQ X (CDR S1))
(GO C)
B (SETQ Y (PLUS (TIMES (CAR S1)
(CDR S2))
(CDR S1)))
(SETQ X (CDR S2))
(GO C])
(SLOPE
[LAMBDA (X1 X2 Y1 Y2)
(PROG (SL)
(COND
((EQUAL X1 X2)
(GO A)))
(SETQ SL (QUOTIENT (FLOAT (DIFFERENCE Y2 Y1))
(DIFFERENCE X2 X1)))
[RETURN (CONS SL (DIFFERENCE Y2 (TIMES SL X2]
A (RETURN (CONS 1024.0 X1])
(SRTLNA
[LAMBDA (X Y Y1)
(PROG NIL
(COND
((MEMBER X Y)
(RETURN Y)))
(SETA TMP X (PLUS Y1 (ELT TMP X)))
(RETURN (CONS X Y])
)
(DEFINEQ
(DRAW
[LAMBDA (STRUC RAD)
(PROG (O CTAB (TITLE ""))
(COND
((STRUCTURE? STRUC)
(DRAWS STRUC))
[(STRUCTURE? (CAR STRUC))
(DRAWS (CAR STRUC))
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (X)
(PAUSE)
(DRAWS X]
((EQ RAD T)
(PRINRAD STRUC))
[(EQ RAD (QUOTE L))
(PRINRAD (CAR STRUC))
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (XZ)
(PAUSE)
(PRINRAD XZ]
[(EQ RAD (QUOTE AL))
[COND
[(STRUCTURE? (CDAR STRUC))
(DRAWS (CDAR STRUC)
(LIST (QUOTE STRUCTURE)
(QUOTE #)
(CAAR STRUC]
(T [SETQ TITLE (LIST (APPEND (QUOTE (STRUCTURE #))
(CAAR STRUC]
(PRINRAD (CDAR STRUC]
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (S)
(PAUSE)
(COND
[(STRUCTURE? (CDR S))
(DRAWS (CDR S)
(LIST (QUOTE STRUCTURE)
(QUOTE #)
(CAR S]
(T (SETQ TITLE (APPEND (QUOTE (STRUCTURE
#))
(CAR S)))
(PRINRAD (CDR S]
(T (ERROR "BAD STRUCTURE"])
(DRAWS
[LAMBDA (STRUC ID)
(PROG (CTAB)
(SETQ CTAB (CTABLE STRUC))
(LAYOUT
(CONS (OR ID (UGRAPH STRUC))
(MAPCAR
CTAB
(FUNCTION (LAMBDA (CTE)
(CONS (NODENUM CTE)
(CONS (ATOMTYPE (MARKERS CTE))
(SUBSET
(NBRS CTE)
(FUNCTION (LAMBDA (X)
(NOT (EQ X (QUOTE FV])
(PRINRAD
[LAMBDA (L)
(PROG (CTAB)
(PRINRAD1 NIL (FOR NEW I :=((NUMNODES L)
1 -1)
XLIST I)
L)
(LAYOUT (CONS TITLE CTAB])
(PRINENTRY
[LAMBDA (N AT CON)
(SETQ CTAB (CONS (CONS N (CONS AT CON))
CTAB])
(PAUSE
[LAMBDA NIL
(PROG NIL
LP (PRIN1 "READY ? ")
(COND
((RESETVAR DWIMWAIT 10 (EQ (Y/N Y)
(QUOTE Y)))
(RETURN))
(T (GO LP])
)
(DEFINEQ
(/ONCOC
[LAMBDA (CHARS)
(SETQ CHARS (ONCOC CHARS))
(UNDOSAVE (LIST (QUOTE SFCOC)
T
(CAR CHARS)
(CDR CHARS)))
CHARS])
(RESETCOC
[NLAMBDA (CHARS FORM)
(EVAL (SUBPAIR (QUOTE (FORM CHARS))
(LIST FORM CHARS)
(QUOTE (PROG (MACROX MACROY)
(SETQ MACROX (ONCOC CHARS))
(SETQ MACROX
(SETQ RESETVARSLST
(CONS (LIST (LIST (QUOTE SFCOC)
T
(CAR MACROX)
(CDR MACROX)))
RESETVARSLST)))
(SETQ MACROY (XNLSETQ FORM))
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (QUOTE SFCOC)
(CDAAR MACROX))
[COND
(MACROY (RETURN (CAR MACROY]
(ERROR!])
(SFCOC
[LAMBDA (FILE N M)
(ASSEMBLE NIL
(CQ (VAG (OPNJFN FILE)))
(PUSHN)
(CQ (VAG N))
(PUSHN)
(CQ (VAG M))
(MOVE 3 , 1)
(POP NP , 2)
(POPN)
(JSYS 75) (* SFCOC)
(CQ T])
(SETCOC
[LAMBDA (N VAL)
(PROG ([N (OR (NUMBERP N)
(CAR (CHCON N]
(V (RFCOC T)))
(COND
((IGREATERP N 17)
(SFCOC T (CAR V)
(M (CDR V)
(IDIFFERENCE N 18)
VAL))
(RFCOC T))
(T (SFCOC T (M (CAR V)
N VAL)
(CDR V))
(RFCOC T])
(M
[LAMBDA (W V I)
(LOGOR (LOGAND W (LOGXOR (LSH 3 (IDIFFERENCE 34 (ITIMES V 2)))
-1))
(LSH I (IDIFFERENCE 34 (ITIMES V 2])
(RFCOC
[LAMBDA (FILE)
(ASSEMBLE NIL
(CQ (VAG (OPNJFN FILE)))
(JSYS 74) (* RFCOC)
(PUSH NP , 3)
(MOVE 1 , 2)
(CQ (CONS (LOC (AC))
(LOC (ASSEMBLE NIL
(POPN])
(PRINBRIT
[LAMBDA (X)
(SETCOC 14 2)
(SETCOC 15 2)
(PRIN1 "∞")
(PRIN1 X)
(PRIN1 (CHARACTER 15])
(CLEAR
[LAMBDA NIL
(SETCOC 26 2)
(SETCOC 24 2)
(PRIN1 "_~~~~~~~~~~~~~~~")
(SETCOC 24 1)
(SETCOC 26 1])
(ONCOC
[LAMBDA (CHARS)
(PROG ((N (SELECTQ (NTYP CHARS)
[8 (MAPCAR CHARS (FUNCTION (LAMBDA (X)
(OR (AND (SMALLP X)
X)
(CAR (CHCON X]
((12 24 28)
(CHCON CHARS))
(20 (LIST CHARS))
(ERROR "FUNNY ARG TO ONCOC:" CHARS)))
(V (RFCOC T))
V1 V2)
(SETQ V1 (CAR V))
(SETQ V2 (CDR V))
[MAPC N (FUNCTION (LAMBDA (N1)
(COND
((IGREATERP N1 17)
(SETQ V2 (M V2 (IDIFFERENCE N1 18)
2)))
(T (SETQ V1 (M V1 N1 2]
(SFCOC T V1 V2)
(RETURN V])
)
(DEFLIST(QUOTE(
[RESETCOC ((CHARS FORM)
(PROG (MACROX MACROY)
(SETQ MACROX (ONCOC CHARS))
(SETQ MACROX (SETQ
RESETVARSLST
(CONS (LIST (LIST (QUOTE SFCOC)
T
(CAR MACROX)
(CDR MACROX)))
RESETVARSLST)))
(SETQ MACROY (XNLSETQ FORM))
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (QUOTE SFCOC)
(CDAAR MACROX))
[COND (MACROY (RETURN (CAR MACROY]
(ERROR!]
))(QUOTE MACRO))
STOP